Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue46/ComCorn/ServMain.pas

Pascal/Delphi Source File | 1999-05-05 | 10.2 KB | 345 lines

unit ServMain;

interface

uses
  ActiveX, MtsObj, Mtx, ComObj, TTTServer_TLB;

type
  PGameData = ^TGameData;
  TGameData = array[1..3, 1..3] of Byte;

  TGameServer = class(TMtsAutoObject, IGameServer)
  private
    procedure CalcComputerMove(GameData: PGameData; Skill: SkillLevels;
      var X, Y: Integer);
    function CalcGameStatus(GameData: PGameData): GameResults;
    function GetSharedPropertyGroup: ISharedPropertyGroup;
    procedure CheckCallerSecurity;
  protected
    procedure NewGame(out GameID: Integer); safecall;
    procedure ComputerMove(GameID: Integer; SkillLevel: SkillLevels; out X,
      Y: Integer; out GameRez: GameResults); safecall;
    procedure PlayerMove(GameID, X, Y: Integer; out GameRez: GameResults);
      safecall;
  end;

implementation

uses ComServ, Windows, SysUtils;

const
  GameDataStr = 'TTTGameData%d';
  EmptySpot = 0;
  PlayerSpot = $1;
  ComputerSpot = $2;

function TGameServer.GetSharedPropertyGroup: ISharedPropertyGroup;
var
  SPGMgr: ISharedPropertyGroupManager;
  LockMode, RelMode: Integer;
  Exists: WordBool;
begin
  if ObjectContext = nil then
    raise Exception.Create('Failed to obtain object context');
  // Create shared property group for this object
  OleCheck(ObjectContext.CreateInstance(CLASS_SharedPropertyGroupManager,
    ISharedPropertyGroupManager, SPGMgr));
  LockMode := LockSetGet;
  RelMode := Process;
  Result := SPGMgr.CreatePropertyGroup('DelphiTTT', LockMode, RelMode, Exists);
  if Result = nil then
    raise Exception.Create('Failed to obtain property group');
end;

procedure TGameServer.NewGame(out GameID: Integer);
var
  SPG: ISharedPropertyGroup;
  SProp: ISharedProperty;
  Exists: WordBool;
  GameData: OleVariant;
begin
  // Use caller's role to validate security
  CheckCallerSecurity;
  // Get shared property group for this object
  SPG := GetSharedPropertyGroup;
  // Create or retrieve NextGameID shared property
  SProp := SPG.CreateProperty('NextGameID', Exists);
  if Exists then GameID := SProp.Value
  else GameID := 0;
  // Increment and store NextGameID shared property
  SProp.Value := GameID + 1;
  // Create game data array
  GameData := VarArrayCreate([1, 3, 1, 3], varByte);
  SProp := SPG.CreateProperty(Format(GameDataStr, [GameID]), Exists);
  SProp.Value := GameData;
  SetComplete;
end;

procedure TGameServer.ComputerMove(GameID: Integer;
  SkillLevel: SkillLevels; out X, Y: Integer; out GameRez: GameResults);
var
  Exists: WordBool;
  PropVal: OleVariant;
  GameData: PGameData;
  SProp: ISharedProperty;
begin
  // Get game data shared property
  SProp := GetSharedPropertyGroup.CreateProperty(Format(GameDataStr, [GameID]),
    Exists);
  // Get game data array and lock it for more efficient access
  PropVal := SProp.Value;
  GameData := PGameData(VarArrayLock(PropVal));
  try
    // If game isn't over, then let computer make a move
    GameRez := CalcGameStatus(GameData);
    if GameRez = grInProgress then
    begin
      CalcComputerMove(GameData, SkillLevel, X, Y);
      // Save away new game data array
      SProp.Value := PropVal;
      // Check for end of game
      GameRez := CalcGameStatus(GameData);
    end;
  finally
    VarArrayUnlock(PropVal);
  end;
  SetComplete;
end;

procedure TGameServer.PlayerMove(GameID, X, Y: Integer;
  out GameRez: GameResults);
var
  Exists: WordBool;
  PropVal: OleVariant;
  GameData: PGameData;
  SProp: ISharedProperty;
begin
  // Get game data shared property
  SProp := GetSharedPropertyGroup.CreateProperty(Format(GameDataStr, [GameID]),
    Exists);
  // Get game data array and lock it for more efficient access
  PropVal := SProp.Value;
  GameData := PGameData(VarArrayLock(PropVal));
  try
    // Make sure game isn't over
    GameRez := CalcGameStatus(GameData);
    if GameRez = grInProgress then
    begin
      // If spot isn't empty, raise exception
      if GameData[X, Y] <> EmptySpot then
        raise Exception.Create('Spot is occupied!');
      // Allow move
      GameData[X, Y] := PlayerSpot;
      // Save away new game data array
      SProp.Value := PropVal;
      // Check for end of game
      GameRez := CalcGameStatus(GameData);
    end;
  finally
    VarArrayUnlock(PropVal);
  end;
  SetComplete;
end;

function TGameServer.CalcGameStatus(GameData: PGameData): GameResults;
var
  I, J: Integer;
begin
  // First check for a winner
  if GameData[1, 1] <> EmptySpot then
  begin
    // Check top row, left column, and top left to bottom right diagonal for win
    if ((GameData[1, 1] = GameData[1, 2]) and (GameData[1, 1] = GameData[1, 3])) or
      ((GameData[1, 1] = GameData[2, 1]) and (GameData[1, 1] = GameData[3, 1])) or
      ((GameData[1, 1] = GameData[2, 2]) and (GameData[1, 1] = GameData[3, 3])) then
    begin
      Result := GameData[1, 1] + 1; // Game result is spot ID + 1
      Exit;
    end;
  end;
  if GameData[3, 3] <> EmptySpot then
  begin
    // Check bottom row and right column for win
    if ((GameData[3, 3] = GameData[3, 2]) and (GameData[3, 3] = GameData[3, 1])) or
      ((GameData[3, 3] = GameData[2, 3]) and (GameData[3, 3] = GameData[1, 3])) then
    begin
      Result := GameData[3, 3] + 1; // Game result is spot ID + 1
      Exit;
    end;
  end;
  if GameData[2, 2] <> EmptySpot then
  begin
    // Check middle row, middle column, and bottom left to top right diagonal for win
    if ((GameData[2, 2] = GameData[2, 1]) and (GameData[2, 2] = GameData[2, 3])) or
      ((GameData[2, 2] = GameData[1, 2]) and (GameData[2, 2] = GameData[3, 2])) or
      ((GameData[2, 2] = GameData[3, 1]) and (GameData[2, 2] = GameData[1, 3])) then
    begin
      Result := GameData[2, 2] + 1; // Game result is spot ID + 1
      Exit;
    end;
  end;
  // Finally, check for game still in progress
  for I := 1 to 3 do
    for J := 1 to 3 do
      if GameData[I, J] = 0 then
      begin
        Result := grInProgress;
        Exit;
      end;
  // If we get here, then we've tied
  Result := grTie;
end;

procedure TGameServer.CalcComputerMove(GameData: PGameData;
  Skill: SkillLevels; var X, Y: Integer);
type
  // Used to scan for possible moves by either row, column, or diagonal line
  TCalcType = (ctRow, ctColumn, ctDiagonal);
  // mtWin = one move away from win, mtBlock = opponent is one move away from
  // win, mtOne = I occupy one other spot in this line, mtNew = I occupy no
  // spots on this line
  TMoveType = (mtWin, mtBlock, mtOne, mtNew);
var
  CurrentMoveType: TMoveType;

  function DoCalcMove(CalcType: TCalcType; Position: Integer): Boolean;
  var
    RowData, I, J, CheckTotal: Integer;
    PosVal, Mask: Byte;
  begin
    Result := False;
    RowData := 0;
    X := 0;
    Y := 0;
    if CalcType = ctRow then
    begin
      I := Position;
      J := 1;
    end
    else if CalcType = ctColumn then
    begin
      I := 1;
      J := Position;
    end
    else begin
      I := 1;
      case Position of
        1: J := 1; // scanning from top left to bottom right
        2: J := 3; // scanning from top right to bottom left
      else
        Exit;   // bail; only 2 diagonal scans
      end;
    end;
    // Mask masks off Player or Computer bit, depending on whether we're thinking
    // offensively or defensively.  Checktotal determines whether that is a row
    // we need to move into.
    case CurrentMoveType of
      mtWin:
        begin
          Mask := PlayerSpot;
          CheckTotal := 4;
        end;
      mtNew:
        begin
          Mask := PlayerSpot;
          CheckTotal := 0;
        end;
      mtBlock:
        begin
          Mask := ComputerSpot;
          CheckTotal := 2;
        end;
    else
      begin
        Mask := 0;
        CheckTotal := 2;
      end;
    end;
    // loop through all lines in current CalcType
    repeat
      // Get status of current spot (X, O, or empty)
      PosVal := GameData[I, J];
      // Save away last empty spot in case we decide to move here
      if PosVal = 0 then
      begin
        X := I;
        Y := J;
      end
      else
        // If spot isn't empty, then add masked value to RowData
        Inc(RowData, (PosVal and not Mask));
      if (CalcType = ctDiagonal) and (Position = 2) then
      begin
        Inc(I);
        Dec(J);
      end
      else begin
        if CalcType in [ctRow, ctDiagonal] then Inc(J);
        if CalcType in [ctColumn, ctDiagonal] then Inc(I);
      end;
    until (I > 3) or (J > 3);
    // If RowData adds up, then we must block or win, depending on whether we're
    // thinking offensively or defensively.
    Result := (X <> 0) and (RowData = CheckTotal);
    if Result then
    begin
      GameData[X, Y] := ComputerSpot;
      Exit;
    end;
  end;

var
  A, B, C: Integer;
begin
  if Skill = slAwake then
  begin
    // First look to win the game, next look to block a win
    for A := Ord(mtWin) to Ord(mtBlock) do
    begin
      CurrentMoveType := TMoveType(A);
      for B := Ord(ctRow) to Ord(ctDiagonal) do
        for C := 1 to 3 do
          if DoCalcMove(TCalcType(B), C) then Exit;
    end;
    // Next look to take the center of the board
    if GameData[2, 2] = 0 then
    begin
      GameData[2, 2] := ComputerSpot;
      X := 2;
      Y := 2;
      Exit;
    end;
    // Next look for the most advantageous position on a line
    for A := Ord(mtOne) to Ord(mtNew) do
    begin
      CurrentMoveType := TMoveType(A);
      for B := Ord(ctRow) to Ord(ctDiagonal) do
        for C := 1 to 3 do
          if DoCalcMove(TCalcType(B), C) then Exit;
    end;
  end;
  // Finally (or if skill level is unconscious), just find the first open place
  for A := 1 to 3 do
    for B := 1 to 3 do
      if GameData[A, B] = 0 then
      begin
        GameData[A, B] := ComputerSpot;
        X := A;
        Y := B;
        Exit;
      end;
end;

procedure TGameServer.CheckCallerSecurity;
begin
  // Just for fun, only allow those in the "TTT" role to play the game.
  if IsSecurityEnabled and not IsCallerInRole('TTT') then
    raise Exception.Create('Only those in the TTT role can play tic-tac-toe');
end;

initialization
  TAutoObjectFactory.Create(ComServer, TGameServer, Class_GameServer,
    ciMultiInstance, tmApartment);
end.